perm filename SORT.F4[P,LCS] blob
sn#359771 filedate 1978-06-05 generic text, type C, neo UTF8
COMMENT ā VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 DIMENSION I(128),X(10000),Y(10000)
C00005 ENDMK
Cā;
DIMENSION I(128),X(10000),Y(10000)
COMMON /JNY/J,N,Y /XY/XX,YY /X/X
IMPLICIT INTEGER (X-Z,D-E)
CALL GETFIL('XX')
XX=10000
YY=0
M=1
N=1
1 CALL FASTIN(I,128)
TYPE 100,I(1)
NN=I(1)+1
DO 2 KK=2,NN
CALL UNPAC (I(KK),J,K,L)
K=K+10000
IF(L.EQ.3)K=-K
IF(L.LE.0)GO TO 2
C SKIP IF THIS GROUP OF SEGS HAS BEEN USED (ALSO -3)
IF(J.NE.XX)GO TO 3
CATCHES DUPLICATES
IF(K.EQ.YY)GO TO 2
3 X(N)=J
Y(N)=K
XX=J
YY=K
CC TYPE 100,N,J,K,L
N=N+1
IF(N.LE.10000)GO TO 2
PAUSE 'PASSED ARRAY LIMIT'
GO TO 21
2 CONTINUE
IF(NN.EQ.128)GO TO 1
21 J=2
20 CALL GETNXT(K)
XOLD=XX
YOLD=YY
DIS=10000
5 J=K+1
CALL GETNXT(K)
D=DIST(XOLD,YOLD,XX,YY)
50 TYPE 100,D
IF(D.GE.DIS)GO TO 4
TYPE 100,D,DIS
M=J
DIS=D
X2=XX
Y2=YY
4 IF(K.LT.N)GO TO 5
C NOW FOUND NEXT CLOSEST SEG GROUP
C CALL OUTARY
Y(M-1)=0
X(M-1)=LAST
IF(LAST.LT.N)GO TO 5
CALL OUTARY
100 FORMAT(4I)
END
INTEGER FUNCTION DIST(XOLD,YOLD,X,Y)
IMPLICIT INTEGER (X-Z)
A=IABS(XOLD-X)
B=IABS(YOLD-Y)
DIST=SQRT(A**2+B**2)
END
SUBROUTINE GETNXT(K)
COMMON /JNY/J,N,Y(1) /XY/XX,YY /X/X(1)
IMPLICIT INTEGER (X-Z)
4 IF(Y(J).NE.0)GO TO 3
J=X(J)
GO TO 4
3 DO 1 K=J,N-1
1 IF(Y(K))GO TO 2
C NEG VALUE = PEN UP
2 XX=X(J)
YY=10000+Y(J)
END